Internet Info 1994 March

home *** CD-ROM | disk | FTP | other *** search

/ Internet Info 1994 March / Internet Info CD-ROM (Walnut Creek) (March 1994).iso / networking / terms / kermit / b / ikmutl.asm < prev next >

Wrap

Assembly Source File | 1992-09-29 | 111.1 KB | 1,406 lines

*COPY IKMUTL 05000000 CHECKVER IKCUTL,4.2 @SC90072 05000500 TITLE 'CWDSET/DSPACE Routines - set/show working directory' 05001000 * Set new 'working directory', i.e., new code (need LSCAN or FILES) 05002000 * Entry: SCANPTR string has option 05003000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged. 05004000 CWDSET ENTER @SC86164 05005000 NTOKN N=CWDRSET,H=CWDERR 05006000 C 7,F3 Length MUST be 4 05007000 BNE CWDERR 05008000 TM UPRIVS,LSCAN+FILES Need some priveleges to 05009000 BZ CWDPRV change code 05010000 TR 0(4,6),UPCASE Upper case it 05011000 MVC UCODE(4),0(6) Save as new default code 05012000 MVI DESTL,1 Yes, new code 05013000 B RTRN0 @SC86295 05014000 CWDPRV PTEXT 'Not enough privileges to change code' 05015000 B SUBERR 05016000 CWDRSET MVI DESTL,0 No more code. Default to user's 05017000 MVC UCODE(4),$USRCDE Get user's code from locore 05018000 B RTRN0 05019000 CWDERR PTEXT 'Must be a valid 4-digit MUSIC code' 05020000 B SUBERR Go display error msg 05021000 * * * * * * * * * * * * * * * * * * * * * * 05022000 * 05023000 * 05024000 * DSPACE Routine - display available disk space @SC86164 05025000 * 05026000 * Show space available in 'working directory' or other area 05027000 * Entry: SCANPTR string has option (none => working directory) 05028000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged 05029000 DSPACE ENTER ALT @SC86164 05030000 MFSET DSKST,USERCTL 05031000 MFREQ DSKST Get User Control Record 05032000 LA 15,PARMAREA Temporary output buffer 05033000 L 4,MFMAXS Calculate space in use 05034000 S 4,MFACUR 05035000 BAL 2,EDDEC Convert to printable 05036000 MVC 0(12,15),=C' KBytes Free' 05037000 LA 0,12(15) 05038000 LA 1,PARMAREA 05039000 SR 0,1 05040000 WTEXT (1),(0) Display the message 05041000 B RTRN0 05042000 LOCALS , @SC86295 05043000 EXIT , @SC86295 05044000 TITLE 'FSPEC Routine - extract filespec from scan string' 05045000 * 05046000 * Entry: R1->name field, R0=flags selecting operation (see below) 05047000 * For parse operations, SCANPTR defines the input string. 05048000 * For getting foreign or display filespec, R7->output buffer 05049000 * Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad. 05050000 * For R15=1 or 2 R3,R4 give message. ERRNUM may be leftover. 05051000 * 05052000 * Flags: Notes: 05053000 * Tasks: FFRCF FFSND FFGET FFNEW 05054000 * Parse RECV X set ROVR properly 05055000 * Parse SEND 1st X 05056000 * Parse SEND 2nd X X 05057000 * Parse GET 1st X 05058000 * Parse GET 2nd X X set ROVR properly 05059000 * Parse F-packet (FFHDR) X X X 05060000 * Parse for Generic(FFUTL) X X FFWLD: allow partial 05061000 * Parse TAKE 05062000 * 05063000 * Get unique name X R15: 0=>ok, 1=>bad 05064000 * Interactive name check X X R15: 0=>ok, 1=>bad 05065000 * Get foreign name (FFENC) X X R15->end of string 05066000 * Get display form (FFDSP) X X R15->end of string 05067000 * 05068000 FSPEC ENTER @SC86295 05069000 STC 0,FSPFLG @SC86295 05070000 LR 5,0 @SC88049 05071000 SRL 5,4 Convert flags to index @SC88049 05072000 AR 5,5 @SC88049 05073000 LR 0,1 Copy ptr to filespec @SC86295 05074000 TM FSPFLG,FFNEW @SC86295 05075000 BO FSPWRN @SC86295 05076000 MVC 0(LFID,1),BLNAME Clear the filename to blanks 05077000 PTEXT 'Invalid filename' 05078000 MVI ERRNUM,ERRFNE Assume bad file name @SC86158 05079000 LH 5,FSP0(5) Get dispatch adr @SC88049 05080000 B FSP0(5) Go to proper handler @SC88049 05081000 * 05082000 * Take Get 1st Send 1st Generic 05083000 FSP0 DC AL2(FSPTAK-FSP0,FSPSN2-FSP0,FSPSND-FSP0,FSPUTL-FSP0) 05084000 * 05085000 * Receive Get 2nd Send 2nd F-packet 05086000 DC AL2(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0) 05087000 SPACE 05088000 FSPUTL TM FSPFLG,FFWLD Utility: default to all files? @SC88049 05089000 BZ FSPASC No @SC86295 05090000 MVC 0(5,1),UCODE Default prefix 05091000 MVI 5(1),C'*' Yes @SC88308 05092000 FSPSND DS 0H 05093000 FSPASC TM FL2,SRV Server mode? @SC86295 05094000 BZ FSPCPY No, don't need to convert @SC86295 05095000 ICM 15,15,LEN Get length @SC86295 05096000 BZ FSPCPY @SC86295 05097000 BCTR 15,0 Correct for EX @SC86158 05098000 L 5,ADR Get string ptr @SC89215 05099000 EX 15,FSPTRAE Change to EBCDIC @SC89215 05100000 EX 15,FSPTRUP Upcase and dot to space @SC89215 05101000 B FSPCPY @SC86295 05102000 FSPTRAE TR 0(,5),ATOED @SC89301 05102300 FSPTRUP TR 0(,5),UPCASE @SC89215 05102600 FSPRC NI FL1,255-ROVR Setup for RECEIVE @SC86295 05103000 NI FL4,255-NMOK-NMCHNG Collision not checked yet @SC90033 05104000 MVI 0(1),C'$' Default fn @SC88308 05105000 B FSPCPY @SC86295 05106000 FSPHD MVI 0(1),C'$' Default fn @SC88308 05107000 L 2,ADR @SC86295 05108000 IC 7,4(2) Save possible code separator @SC88308 05109000 TR 0(256,2),FSPTAB Make valid fn chars @SC86295 05110000 CLM 7,1,UPCASE+C':' Was it a separator? @SC88308 05111000 BNE *+8 @SC88308 05112000 STC 7,4(2) Yes, change char. back to colon @SC88308 05113000 B FSPCPY @SC86295 05114000 FSPSN2 MVI 0(1),0 Clear JFSPEC length !!! 05115000 CLI BRK,C',' @PG88306 05116000 BE RTRN0 Foreign name omitted @PG88306 05117000 NTOKN H=FSP2H,N=RTRN0 05118000 LA 7,1(7) Not machine length ! 05119000 LA 1,L'JFNAM Get maximum length 05120000 CLM 7,3,*-2 Does it fit? @SC86224 05121000 BNH *+6 Yes @SC86224 05122000 LR 7,1 Use what we can @SC86224 05123000 LR 3,0 @SC86295 05124000 STC 7,0(3) Save length @SC86224 05125000 LA 0,1(3) @SC86295 05126000 MVCL 0,6 Get fn, at least @SC86224 05127000 B RTRN0 @SC86295 05128000 * 05129000 FSPTAK DS 0H 05130000 FSPCPY NTOKN H=FSPH,N=FSPZ 05131000 LR 8,0 Save start 05133000 KCALL FOPSTR,LFID(,8),E=FSPINV @SC89218 05133300 LA 1,LFID Get max length 05133600 CLI 4(6),C':' Code prefix ? 05134000 BE FSPCPC 05135000 LR 2,0 05136000 MVC 0(5,2),UCODE Add the user code 05137000 LA 0,5(2) Point past code prefix 05138000 S 1,F5 Reduce receiving length 05139000 FSPCPC TM FSPFLG,FFRCF 05140000 BZ FSPCPN @SC86295 05141000 OI FL1,ROVR Overwrite received fname @SC86295 05142000 FSPCPN LA 7,1(7) 05143000 ICM 7,8,BLANK 05144000 MVCL 0,6 Copy token with padding 05145000 CLM 7,7,F0 Hope nothing left over! 05146000 BNE FSPINV Name was too long 05147000 TR 0(LFID,8),UPCASE Ok, now upcase it 05148000 B RTRN0 @SC86295 05149000 * 05150000 FSPZ LR 14,0 @SC86295 05151000 CLI 0(14),C' ' Any default given? @SC86295 05152000 BH RTRN0 Yes, use it @SC86295 05153000 FSPMIS PTEXT 'Missing filename' 05154000 FSPINV LA 15,2 @SC86295 05155000 B FSPPTRS @SC86295 05156000 * 05157000 FSPH PTEXT 'Filespec has format: fn[<first-last>]' @SC89218 05158000 CLI FSPFLG,FFSND SEND 1st? @SC89218 05158200 BE *+8 Yes, use whole message @SC89218 05158400 SH 4,=H'14' Chop off option part @SC89218 05158600 B FSP0H @SC86295 05159000 FSP2H PTEXT 'Enter foreign filespec' @SC86295 05160000 FSP0H LA 15,1 @SC86295 05161000 FSPPTRS RETREG 3,4 Return msg ptrs @SC86295 05162000 FSPRET RET , @SC86295 05164000 * 05165000 * Non-parsing functions . . . 05166000 * 05167000 * Get unique filespec 05168000 FSPWRN LR 4,1 Save name ptr @SC86295 05169000 TM FSPFLG,FFENC @SC86295 05170000 BO FSPENC Encode name into buffer @SC86295 05171000 TM FSPFLG,FFDSP @SC86295 05172000 BO FSPDSP Copy name into buffer for display @SC86295 05173000 TM FL4,NMOK Already checked? @SC87012 05174000 BO RTRN0 Yes, ok @SC87012 05175000 MVC XFILE,0(1) Save original name @SC90033 05175500 LA 6,LFID-2(1) End of FT 05176000 BCTR 6,0 @BS86001 05177000 CLI 0(6),C' ' Find end of token @BS86001 05178000 BE *-6 @BS86001 05179000 LA 5,10+1 Allowed retries @BS86001 05180000 LA 7,C'0' Extra character @BS86001 05181000 OI FL4,NMOK Assume it checks @SC87012 05182000 FSPSTA OPENF T,(4),E=RTRN0 Does it exist already? @SC86135 05183000 OI FL4,NMCHNG Yes, remember collision occurred @SC90033 05183500 MVI 1(6),C'$' Yes, modify Fn 05184000 STC 7,2(6) Serialize @BS86001 05185000 LA 7,1(7) Bump counter @BS86001 05186000 BCT 5,FSPSTA @BS86001 05187000 PTEXT 'Filename collision' @SC88049 05188000 B FSP0H Return error code @SC88049 05189000 * 05190000 * Encode name at (R1) into (R7) buffer (in ASCII), possibly with 05191000 * substitution from JFSPEC, but disable subsequent subst. 05192000 * Return updated ptr in R15 05193000 FSPENC LA 1,JFSPEC Complex string? @SC86224 05194000 BAL 14,PAKFOR @SC86224 05195000 LR 15,7 Save ptr 05196000 BNZ FSPFILS Yes, tokens aren't used @SC86224 05197000 MVC 0(LFID,7),BLNAME 05198000 MVC 0(17,7),5(4) Copy filename Only 05199000 CLI 4(4),C':' Is there a code prefix ??? 05200000 BE *+10 05201000 MVC 0(LFID,7),0(4) Copy token 05202000 LA 1,LFID(7) End of token if no blanks 05203000 TRT 0(LFID,7),TRTBL Find 1st blank 05204000 TR 0(LFID,7),ETOAD ASCII it @SC89301 05205000 LR 15,1 New end of string 05206000 FSPFILS MVI JFSPEC,0 Turn off string @SC86224 05207000 B FSPRET @SC86295 05208000 * 05209000 * Copy name at (R1) into (R7) buffer in display form 05210000 * Return updated ptr in R15 05211000 FSPDSP MVC 0(LFID,7),0(4) Copy token 05212000 CLI 4(4),C':' Prefix already ? 05213000 BE FSPDTK3 05214000 MVC 0(5,7),UCODE Get prefix 05215000 MVC 5(LFID-5,7),0(4) 05216000 FSPDTK3 LA 1,LFID(7) End of token if no blanks 05217000 TRT 0(LFID,7),TRTBL Find 1st blank 05218000 LR 15,1 New end of string 05219000 B FSPRET 05220000 * 05221000 * Valid MUSIC file name characters 05222000 FSPTAB DC 75C'$',C'.' dot 05223000 DC 15C'$',C'$' dollar sign 05224000 DC 31C'$',C'#@' pound sign, at sign @SC88308 05225000 DC 04C'$',C'ABCDEFGHI' a-i 05226000 DC 07C'$',C'JKLMNOPQR' j-r 05227000 DC 08C'$',C'STUVWXYZ' s-z 05228000 DC 23C'$',C'ABCDEFGHI' A-I 05229000 DC 07C'$',C'JKLMNOPQR' J-R 05230000 DC 08C'$',C'STUVWXYZ' S-Z 05231000 DC 06C'$',C'0123456789' 0-9 05232000 DC 06C'$' 05233000 LOCALS , @SC86295 05234000 FSPFLG DS X Filespec flags @SC86295 05235000 FSPEC EXIT @SC86295 05236000 TITLE 'KHELP routine - perform HELP command' 05237000 * Handle HELP command, rest of string given by SCANPTR. 05238000 KHELP ENTER , @SC86355 05239000 PTEXT 'LIST *COM:SYSTEM.KERMHELP',AREG=0,LREG=6 @SC88308 05240000 NI FL4,255-UCMD Signal ptrs in R0,R6 @SC88308 05241000 KCALL SUPFNC,3 Execute HOST command @SC88308 05242000 B RTRN @SC88308 05243000 LOCALS , 05244000 KHELP EXIT , @SC87007 05245000 TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05246000 SUPFNC ENTER @SC86295 05247000 * On entry, R1 = operation code, R0 = possible ptr @SC86158 05248000 * Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends) 05249000 * ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11) 05250000 * 1 -> Start typeout interception. N.B. &MAXLR >> 2048 for this 05251000 * 2 -> Clean up afterwards and stop interception 05252000 * 3 -> Execute host command with or without interception 05253000 * If UCMD set, SCANPTR gives text, else R0->text,R6=len 05254000 * 4 -> Execute CP command with or without interception 05255000 * R0->text, R6=len 05256000 * 5 -> Stop interception if going 05257000 * 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null) 05258000 * 7 -> Test for stacked lines, return number in R15 05259000 * 8 -> Log off (doesn't return!) 05260000 * 9 -> Wait specified time 05261000 * 10-> Return clock time in R15 (centisec) 05262000 * 11-> Setup up new prompt string at (R0) 05263000 BCT 1,ICPFIN @SC86158 05264000 * Start interception, initialize ptrs @SC86158 05265000 MVI ERRNUM,ERRNOE OK @SC86158 05266000 LA 0,2048 Suitable offset @SC86158 05267000 A 0,WBUF Output buffer @SC86158 05268000 L 1,TSENT Limit @SC86158 05269000 LR 15,0 @SC86158 05270000 STM 15,0,TXTPTR Save @SC86158 05271000 STM 0,1,SVCOPTR @SC86158 05272000 SR 1,0 Get length @SC86158 05273000 L 15,=X'15000000' @SC86158 05274000 MVCL 0,14 Fill with NL (X'15') @SC86158 05275000 OI SVCFLG,INTERCPT Interception in Progress 05276000 B RTRN0 @SC86295 05277000 * Clean up after interception @SC86295 05278000 ICPFIN BCT 1,ICPHST @SC86158 05279000 L 5,SVCOPTR End of text @SC86158 05280000 ST 5,TXTPTR+4 Save @SC86158 05281000 NI SVCFLG,255-INTERCPT Stop interception 05282000 B RTRN0 05283000 * Stop interception if going 05284000 ICPRST BCT 1,SFCLIN 05285000 NI SVCFLG,255-INTERCPT Stop interception 05286000 B RTRN0 05287000 * Execute host command. Save return code. @SC88308 05288000 ICPHST BCT 1,ICPCP @SC86158 05289000 TM FL4,UCMD @SC88308 05290000 BO *+12 @SC88308 05291000 ST 0,ADR Ptrs are in R0,R6 @SC88308 05292000 ST 6,LEN @SC88308 05293000 NTOKN N=SFCHBAD @SC88308 05294000 SCAN HSTCMDS,RTRN0 Dispatch to handler @SC88308 05295000 SFCHBAD HELP HSTCMDS,RTRNM1 @SC88308 05296000 * 05297000 HSTCMDS KW 'LIBRARY',SFCDIR,MIN=3 @SC88308 05298000 KW 'COPY',SFCCOP,MIN=4 @SC88308 05299000 KW 'PURGE',SFCDEL,MIN=3 @SC88308 05300000 KW 'RENAME',SFCREN,MIN=3 @SC88308 05301000 KW 'LIST',SFCTYP @SC88308 05302000 KW , @SC88308 05303000 * 05304000 SFCDIR LA 3,13 DISKIO dir function code @SC88308 05305000 B SFCUTL @SC88308 05306000 SFCDEL LA 3,14 DISKIO del function code @SC88308 05307000 B SFCUTL @SC88308 05308000 SFCREN LA 3,15 DISKIO ren function code @SC88308 05309000 B SFCUTL @SC88308 05310000 SFCCOP LA 3,16 DISKIO cop function code @SC88308 05311000 B SFCUTL @SC88308 05312000 SFCTYP LA 3,17 DISKIO typ function code @SC88308 05313000 * B SFCUTL @SC88308 05314000 SFCUTL SR 0,0 @SC88308 05315000 KCALL FSPEC,FILNAM,E=SUBERR @SC88308 05316000 CH 3,=H'14' @SC88308 05317000 BNH SFCUT1 Dir/lib or del/pur @SC88308 05318000 CH 3,=H'17' @SC88308 05319000 BE SFCUT1 Type/list @SC88308 05320000 SR 0,0 @SC88308 05321000 KCALL FSPEC,IFILE,E=SUBERR Get 2nd file name @SC88308 05322000 SFCUT1 FTOKN N=SFCUT6 See if anything else in command @SC88308 05323000 PTEXT 'No more operands' @SC88308 05324000 B SUBERR @SC88308 05325000 SFCUT6 LR 0,3 Get function code @SC88308 05326000 LA 2,IFILE Optional 2nd name @SC88308 05327000 KCALL DISKIO,FILNAM Do it @SC88308 05328000 B RTRN @SC88308 05329000 * Execute CP command at (R0) with text interception @SC86158 05330000 ICPCP BCT 1,ICPRST @SC86158 05331000 WTEXT 'CP commands not supported' 05332000 B RTRN0 05333000 * 05334000 SFCLIN BCT 1,SFCSTK @SC86295 05335000 * Retrieve original command line arguments, if any @SC86295 05336000 * Return code =0 if yes, =1 if no @SC86295 05337000 * Leave string in CBUF buffer (up to 256), length in CLEN @SC86295 05338000 L 1,ORGR1 Get original R1 05339000 L 1,0(,1) 05340000 LH 2,0(,1) Get command line parm length 05341000 LA 3,2(,1) Get address of parms 05342000 LTR 2,2 Any parms ??? 05343000 BZ RTRN1 05344000 ST 2,CLEN Save the length 05345000 L 4,CBUF Copy to other buffer 05346000 MVC 0(128,4),0(3) 05347000 LA 3,0(2,3) Now, backscan the command line 05348000 SFCLIN3 BCTR 3,0 buffer to check if there is really 05349000 CLI 0(3),C' ' something. MUSIC should have set the 05350000 BNE RTRN0 length to 0, but under DEBUG, we 05351000 BCT 2,SFCLIN3 get a blank line of length 80 !!! 05352000 B RTRN1 05353000 * 05354000 * Test for stacked commands @SC86295 05355000 * return code = number of stacked lines @SC86295 05356000 SFCSTK BCT 1,SFCKIL @SC86295 05357000 ICM 15,15,GTPB+4 Anything in line buffer? 05358000 BH RTRN1 There's one line, at least 05359000 B RTRN0 Nothing stacked 05360000 * 05361000 * Log out @SC86295 05362000 SFCKIL BCT 1,SFCWT @SC86295 05363000 LA 1,OFFARG Schedule a signoff to the system 05364000 SVC 237 $SETSAV 05365000 LA 15,0 And abort the job right away. 05366000 SVC $EOJ 05367000 B RTRN 05368000 * 05369000 * Wait specified time in R0 (sec) 05370000 SFCWT BCT 1,SFCCLK Tell MUSIC to delay for x seconds 05371000 SVC $DLYEXC 05372000 B RTRN0 @SC86295 05373000 * 05374000 * Return time in centisec in R15 05375000 SFCCLK BCT 1,SFCPRP @SC87351 05376000 STCK TMPDW Store TOD clock @SC86295 05377000 LM 14,15,TMPDW @SC86295 05378000 SLDL 14,8 Take mod 204 days @SC86295 05379000 SRDL 14,20 Get in microsec @SC86295 05380000 D 14,=F'10000' Get in centisec @SC86295 05381000 B RTRN @SC86295 05382000 * 05383000 SFCPRP B RTRN0 No action for prompting @SC87351 05384000 OFFARG DC CL6'/OFF**',X'A0' 05385000 LOCALS , @SC86295 05386000 SUPFNC EXIT @SC86158 05387000 TITLE 'Interception Code' 05388000 * 05389000 * Entry: R0->Length of string to write, R1->Address of string 05390000 * 05391000 * Exit: Always R15=0 05392000 * 05393000 ICPTYP ENTER 05394000 LR 2,0 Get length in R2 05395000 LM 3,4,SVCOPTR Yes, then add the line just 05396000 SR 4,3 built to the interception buffer 05397000 CR 2,4 Any room left ? 05398000 BH RTRN0 05399000 BCTR 2,0 05400000 EX 2,ICPMV Move the line to the output buffer 05401000 LA 2,1(2) 05402000 LA 3,1(2,3) Update the source pointer 05403000 ST 3,SVCOPTR Save it 05404000 B RTRN0 05405000 ICPMV MVC 0(0,3),0(1) 05406000 LOCALS , 05407000 ICPTYP EXIT , 05408000 TITLE 'SETMSG Routine - controls CP breakin' 05409000 * Entry: R1 selects operation 05410000 * Exit: R15=0 if ok 05411000 * 1-> Analyze user environment, determine if suitable. 05412000 * Save quantities needed and condition line for entering commands. 05413000 * Perform any system-dependent initialization. 05414000 * 2-> Condition line for protocol transfers. 05415000 * 3-> Decondition line at end of transfer. 05416000 * 4-> System-dependent clean-up at exit. 05417000 * 5-> Reperform system-dependent initialization after SET LINE. 05418000 SETMSG ENTER , 05419000 BCT 1,STM2 Go if R1 not 1, so no init 05420000 MFARG 0,RLAB=ZRC,ULAB=ZLU @PG90057 05421000 MFARG NAME=MFNAME,INFIN=ZINFIN,INFOUT=ZINFOUT,ARG=ZARG 05422000 MFARG PHYS=ZPHYS,UCTL=ZUCTL,UINFO=ZUINFO,TAG=MFTAG 05423000 MFARG EOFPT=ZEOFPT,FSARG=ZFSARG 05424000 MFGEN AREA=DSKST 05425000 MVC UCODE(4),$USRCDE Get the user's code 05426000 MVI UCODE+4,C':' Set up 5-char prefix string 05427000 MVI SCODE+4,C':' Ditto @SC88308 05428000 LA 1,STMNOPR 05429000 SVC $SETOPT Disable prompting 05430000 LA 1,STMTXLC 05431000 SVC $SETOPT Allow lower case input 05432000 MVI TRMTP,C'T' 1st assume TTY @SC88203 05433000 TM $TRMTYP,X'20' Check the terminal type 05434000 BZ RTRN0 05435000 MVI TRMTP,C'S' Remember going via S/1 05436000 L 8,S1RDPL @SC88203 05437000 XC 0(9,8),0(8) Zero out buffer @SC88203 05438000 LA 0,1 @SC88203 05439000 KCALL SCRNIO Clear screen and set up @SC88203 05440000 * LA 0,6 @SC88203 05441000 * KCALL SCRNIO,STMS1ST Issue status request @SC88203 05442000 * LA 0,5 @SC88203 05443000 * KCALL SCRNIO,S1RDPL Read back status @SC88203 05444000 * LA 0,2 @SC88203 05445000 * KCALL SCRNIO Release screen @SC88203 05446000 * CLI 0(8),X'E4' Check for Yale status response @SC88203 05447000 * BE *+12 Ok @SC88203 05448000 * CLI 0(8),0 Check for Yale status response @SC88203 05449000 * BNE STMGRP No, must be something else @SC88203 05450000 * CLI 3(8),X'11' @SC88203 05451000 * BNE STMGRP No, must be something else @SC88203 05452000 * CLC =X'2B5B5B',6(8) @SC88203 05453000 BE RTRN0 Yes, all set @SC88203 05454000 STMGRP MVI TRMTP,C'G' Assume graphics device @SC88203 05455000 B RTRN0 05456000 * Condition Line for protocol transfers 05457000 STM2 BCT 1,STM3 05458000 CLI TRMTP,C'V' @SC89020 05458300 BE *+12 TTY ==> limited @SC89020 05458600 CLI TRMTP,C'T' TTY terminals can't change handshk 05459000 BNE STM2X 05460000 CLI S1HND,XON User want special one anyway ? 05461000 BNE STM2X 05462000 MVI S1HND,0 System provides the handshake! 05463000 STM2X B RTRN0 05464000 * Decondition line at end of transfer 05465000 STM3 BCT 1,STM4 @SC86316 05466000 B RTRN0 05467000 * System cleanup at exit 05468000 STM4 BCT 1,STM5 Special clean-up @SC87351 05469000 LA 1,STMPRMT Turn on prompting 05470000 SVC $SETOPT 05471000 LA 1,STMTXUC Fold lower case to upper case 05472000 SVC $SETOPT 05473000 B RTRN0 Special clean-up done 05474000 * 05475000 STM5 B RTRN1 Other lines not allowed 05476000 * 05477000 STMNOPR DC X'A0',AL1(1,3,6) Turn off Prompting 05478000 STMPRMT DC X'A0',AL1(0,3,6) Turn on Prompting 05479000 STMTXLC DC X'A0',AL1(1,1,6) Text Lower Case Input 05480000 STMTXUC DC X'A0',AL1(0,1,6) Text Upper Case Input 05481000 * 05482000 STMS1ST DC A(STMS1ORD,L'STMS1ORD) @SC88203 05483000 STMS1ORD DC X'C32B5BBC' WCC + Yale ASCII status request @SC88203 05484000 LOCALS , 05485000 SETMSG EXIT 05486000 TITLE 'GETLIN Routine - Get a line from terminal' @SC87015 05487000 * Entry: R1->buffer of length 256 @SC87015 05488000 * Exit: Buffer filled, R0=length, R15=0 if ok. Else R15=1. @SC87015 05489000 GETLIN ENTER @SC87015 05490000 LR 8,1 Save buffer ptr @SC88095 05491000 LA 9,256 For copying @SC88095 05492000 LM 4,6,GTPB Saved ptrs: start, length, current 05493000 LTR 5,5 Already got something? @SC88095 05494000 BNZ GTL1 Yes, return it @SC87015 05495000 TGET (4),130 Read a line from the terminal 05496000 SLR 2,2 Clear length for return 05497000 LA 5,0(1,4) Point past the end 05498000 BCTR 5,0 Scan back for a non-blank 05499000 CLI 0(5),C' ' 05500000 BE *-6 05501000 LA 5,1(,5) 05502000 SR 5,4 Stripped length 05503000 BNH GTLA Null input 05504000 LR 6,4 Set current read ptr 05505000 ST 5,GTPB+4 Save new length 05506000 GTL1 LR 1,5 Length of stuff @SC88095 05507000 AR 1,4 End of buffer @SC88095 05508000 LR 0,1 Save end @SC88095 05509000 LR 2,1 @SC88095 05510000 SR 2,6 Length of text remaining @SC88095 05511000 BNP GTLA None, return length 0 @SC88095 05512000 SLR 4,4 @SC88095 05513000 IC 4,LNDLM Get delimiter @SC88095 05514000 LA 4,TRTBL(4) Ptr to delimiter char @SC88095 05515000 MVI 0(4),1 Set up to snag delims @SC88095 05516000 MVI TRTBL+C' ',0 And ignore blanks @SC88095 05517000 CR 2,9 Get shorter of 256 and string @SC88095 05518000 BNH *+6 @SC88095 05519000 LR 2,9 @SC88095 05520000 BCTR 2,0 Set up for EX @SC88095 05521000 EX 2,GTLTRT @SC88095 05522000 MVI 0(4),0 Now clear out table @SC88095 05523000 MVI TRTBL+C' ',1 And restore @SC88095 05524000 SR 1,6 Length of line @SC88095 05525000 LR 7,1 Set up MVCL @SC88095 05526000 CR 9,7 Get shorter of 256 and string @SC88095 05527000 BNH *+6 @SC88095 05528000 LR 9,7 @SC88095 05529000 LR 2,9 Length actually copied @SC88095 05530000 MVCL 8,6 @SC88095 05531000 AR 6,7 In case we couldn't use it all @SC88095 05532000 CR 6,0 Finished input? @SC88095 05533000 BNL GTLA Yes, release it @SC88095 05534000 LA 6,1(,6) Skip over linend char @SC88095 05535000 ST 6,GTPB+8 Next read ptr @SC88095 05536000 B GTLZ Return @SC88095 05537000 GTLA MVC GTPB+4,F0 Clear input indicator @SC87015 05538000 GTLZ RETREG (0,2) Return (2) as R0 @SC89218 05539000 B RTRN0 @SC87015 05541000 GTLTRT TRT 0(,6),TRTBL Find a delimiter @SC88095 05542000 LOCALS , @SC87015 05543000 GETLIN EXIT , @SC87015 05544000 TITLE 'TERMIO Routine - Handle terminal I/O' 05545000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05546000 * successfull, R15 returns transferred byte count (else returns -1). 05547000 * Command code is in R0: 05548000 * 1 => Open line for I/O 4 => Write packet 05549000 * 2 => Close line 5 => Read packet 05550000 * 3 => Reset line status after ( 6 => Write message ) not used 05551000 * environment changes 05552000 * 05553000 TERMIO ENTER 05554000 SR 15,15 OK @SC86295 05555000 BCT 0,TRMCLS @SC86295 05556000 * Open terminal line for protocol 05557000 MVI RIOC,X'80' Nothing saved @SC86295 05558000 MVI TRMFLG,X'FF' Initialize w/r flag @SC87275 05559000 LA 1,STMNOCR 05560000 SVC $SETOPT No CRLF added 05561000 LA 1,STMNOTR 05562000 SVC $SETOPT No translate Input 05563000 LA 1,STMNOER 05564000 SVC $SETOPT No *TRANSMISSION ERROR messages 05565000 CLI TIMOUT,0 Timeout wanted ??? 05566000 BE RTRN0 05567000 LA 1,STMTMOU 05568000 SVC $SETOPT Timeout on reads 05569000 B RTRN0 05570000 * Close terminal line after protocol transfer 05571000 TRMCLS BCT 0,TRMRSET @SC86295 05572000 LA 1,STMCRLF Reenable CRLF 05573000 SVC $SETOPT 05574000 LA 1,STMTRIN Reenable translation 05575000 SVC $SETOPT 05576000 LA 1,STMNOTM No timeouts 05577000 SVC $SETOPT 05578000 LA 1,STMTRER 05579000 SVC $SETOPT *TRANSMISSION ERROR messages allowed 05580000 B RTRN0 @SC86295 05581000 * (Re)set terminal characteristics to suit environment 05582000 TRMRSET BCT 0,TRMRW @SC86295 05583000 B RTRN0 @SC86295 05584000 * 05585000 * Perform I/O request 05586000 TRMRW BCT 0,TRMRD @SC87275 05587000 CLI WRRD,0 Write/read? @SC87275 05588000 BNE *+8 No, do it immediately 05589000 MVI TRMFLG,0 Indicate no action on follow-up 05590000 LM 2,3,0(1) Get buffer address + length 05591000 BCTR 2,0 Backup to insert carriage control 05592000 MVI 0(2),X'41' No output translate PLEASE ! 05593000 ST 2,TRMRBUF Setup I/O buffer for MFIO 05594000 LA 3,1(3) Fixup length for CC added 05595000 ST 3,TRMRLEN Set I/O length 05596000 MFREQ PRT 05597000 B RTRN0 @SC87275 05598000 * 05599000 TRMRD TS TRMFLG @SC87275 05600000 BZ RTRN0 Just a follow-up. 0-length read @SC87275 05601000 LM 2,3,0(1) 05602000 C 3,AMAXRT Check for maximum length 05603000 BL TRMRD3 05604000 L 3,AMAXRT Not too long please... 05605000 TRMRD3 ST 2,TRMRBUF Setup I/O buffer for MFIO 05606000 ST 3,TRMRLEN Set I/O length 05607000 SLR 4,4 05608000 SLR 5,5 05609000 MVCL 2,4 Clear the input buffer 05610000 MFREQ TRM 05611000 ICM 15,15,TRMARSZ Get number of bytes read 05612000 BNZ RTRN Ok, got a buffer 05613000 L 2,TRMRBUF 05614000 MVI 0(2),X'2B' Timeout !!! 05615000 B RTRN1 Return Length 1 05616000 * 05617000 STMNOCR DC X'A0',AL1(1,1,5) Turn off CRLF 05618000 STMCRLF DC X'A0',AL1(0,1,5) Turn on CRLF 05619000 STMNOTR DC X'A0',AL1(1,1,4) Turn off input translation 05620000 STMTRIN DC X'A0',AL1(0,1,4) Turn on input translation 05621000 STMTMOU DC X'A0',AL1(1,1,0) Turn on Timeout 05622000 STMNOTM DC X'A0',AL1(0,1,0) Turn off Timeout 05623000 STMNOER DC X'A0',AL1(0,1,7) Don't allow *TRANSMISSION ERROR msg 05624000 STMTRER DC X'A0',AL1(1,1,7) Allow *TRANSMISSION ERROR msg 05625000 SPACE 05626000 *********************************************************************** 05627000 * * 05628000 * Reversing Table. Translate ASCII to reverse ASCII * 05629000 * * 05630000 *********************************************************************** 05631000 SPACE 1 05632000 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 05633000 ATORA DC X'008040C020A060E0109050D030B070F0' 0 05634000 DC X'088848C828A868E8189858D838B878F8' 1 05635000 DC X'048444C424A464E4149454D434B474F4' 2 05636000 DC X'0C8C4CCC2CAC6CEC1C9C5CDC3CBC7CFC' 3 05637000 DC X'028242C222A262E2129252D232B272F2' 4 05638000 DC X'0A8A4ACA2AAA6AEA1A9A5ADA3ABA7AFA' 5 05639000 DC X'068646C626A666E6169656D636B676F6' 6 05640000 DC X'0E8E4ECE2EAE6EEE1E9E5EDE3EBE7EFE' 7 05641000 DC X'018141C121A161E1119151D131B171F1' 8 05642000 DC X'098949C929A969E9199959D939B979F9' 9 05643000 DC X'058545C525A565E5159555D535B575F5' A 05644000 DC X'0D8D4DCD2DAD6DED1D9D5DDD3DBD7DFD' B 05645000 DC X'038343C323A363E3139353D333B373F3' C 05646000 DC X'0B8B4BCB2BAB6BEB1B9B5BDB3BBB7BFB' D 05647000 DC X'078747C727A767E7179757D737B777F7' E 05648000 DC X'0F8F4FCF2FAF6FEF1F9F5FDF3FBF7FFF' F 05649000 *********************************************************************** 05650000 * * 05651000 * Reversing Table. Reverse ASCII to ASCII. Lose high order bit. * 05652000 * * 05653000 *********************************************************************** 05654000 SPACE 1 05655000 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 05656000 RATOA DC X'00004040202060601010505030307070' 0 05657000 DC X'08084848282868681818585838387878' 1 05658000 DC X'04044444242464641414545434347474' 2 05659000 DC X'0C0C4C4C2C2C6C6C1C1C5C5C3C3C7C7C' 3 05660000 DC X'02024242222262621212525232327272' 4 05661000 DC X'0A0A4A4A2A2A6A6A1A1A5A5A3A3A7A7A' 5 05662000 DC X'06064646262666661616565636367676' 6 05663000 DC X'0E0E4E4E2E2E6E6E1E1E5E5E3E3E7E7E' 7 05664000 DC X'01014141212161611111515131317171' 8 05665000 DC X'09094949292969691919595939397979' 9 05666000 DC X'05054545252565651515555535357575' A 05667000 DC X'0D0D4D4D2D2D6D6D1D1D5D5D3D3D7D7D' B 05668000 DC X'03034343232363631313535333337373' C 05669000 DC X'0B0B4B4B2B2B6B6B1B1B5B5B3B3B7B7B' D 05670000 DC X'07074747272767671717575737377777' E 05671000 DC X'0F0F4F4F2F2F6F6F1F1F5F5F3F3F7F7F' F 05672000 LOCALS , @SC86295 05673000 EXIT 05674000 TITLE 'SCRNIO Routine - Handle screen I/O via Series/1' 05675000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05676000 * successfull, R15 returns transferred byte count (else returns -1). 05677000 * Command code is in R0: 05678000 * 0 => Clear screen on console (not comm line) @SC90045 05678500 * 1 => Open screen for I/O 4 => Write packet 05679000 * 2 => Close screen 5 => Read packet 05680000 * 3 => Reset screen status after 6 => Write message 05681000 * environment changes 05682000 * 05683000 SCRNIO ENTER 05684000 XC ZFSARG(20),ZFSARG Clear FSIO Control Block 05685000 LTR 0,0 @SC90045 05685300 BZ SCRCLR @SC90045 05685600 BCT 0,SCRCLS @SC86295 05686000 MVI TRMFLG,X'FF' Initialize W/R flag @PG90058 05686500 SCRCLRA MVI FSFSFG,X'84' Write erase needed to setup FSIO @SC90045 05687000 MVI FSFSFG+1,X'60' No data Compression 05688000 MVI ZLU,9 Specify Unit 9 05689000 MFSET DSKST,FSIO 05690000 MFREQ DSKST Do the I/O 05691000 B RTRN0 @SC86295 05692000 * 05692100 SCRCLR CLI TRMTP,C'T' Is it a TTY terminal? @SC90045 05692200 BE RTRN0 Yes, can't clear screen @SC90045 05692300 CLI TRMTP,C'V' Is it a TTY terminal? @SC90045 05692400 BE RTRN0 Yes, can't clear screen @SC90045 05692500 TM FL2,PROTO In protocol mode? @SC90045 05692600 BO RTRN0 Yes, skip clearing screen @SC90045 05692700 B SCRCLRA Do it @SC90045 05692800 * 05693000 SCRCLS BCT 0,SCRRSET @SC86295 05694000 B RTRN0 @SC86295 05695000 * (Re)set device characteristics to suit environment 05696000 SCRRSET BCT 0,SCRRW @SC86295 05697000 B RTRN0 05698000 * 05699000 * Perform I/O request 05700000 SCRRW BCT 0,SCRRD 05701000 CLI WRRD,0 Write/Read ? @PG90058 05702000 BE SCRWO @PG90058 05702200 MVC RIOPRP(8),0(1) Save Write data as Read Prmp @PG90058 05702400 B RTRN0 @PG90058 05702600 SCRWO MVI FSFSFG,X'06' WCC included, Skip read @PG90058 05702800 MVI FSFSFG+1,X'A0' No data Compression 05703000 MVC FSFSWL(4),4(1) Get buffer length 05704000 MVC FSFSWB(4),0(1) Get buffer address 05705000 MVI ZLU,9 Specify Unit 9 05706000 MVI TRMFLG,0 Indicate no actn on followup @PG90058 05706500 MFSET DSKST,FSIO 05707000 MFREQ DSKST Do the I/O 05708000 B RTRN0 05709000 * 05709500 SCRRD BCT 0,SCRWM 05710000 TS TRMFLG Do we have to really read? @PG90058 05711000 BZ RTRN0 Just a follow up. 0-len read @PG90058 05711300 MVI FSFSFG,X'02' Write/Read with Wcc @PG90058 05711600 MVI FSFSFG+1,X'80' No data Compression 05712000 MVC FSFSRL(4),4(1) Get buffer length Read @PG90058 05713000 MVC FSFSRB(4),0(1) Get buffer address Read @PG90058 05713500 MVC FSFSWL(4),RIOPRP+4 Get buffer length Write @PG90058 05714000 MVC FSFSWB(4),RIOPRP Get buffer address Write @PG90058 05714500 MVI ZLU,9 Specify Unit 9 05715000 MFSET DSKST,FSIO 05716000 MFREQ DSKST Do the I/O 05717000 L 15,MFARSZ 05718000 TM FL1,DEBUG If DEBUG is on, then 05719000 BZ RTRN also log the AID and cursor 05720000 TM DBGFLG,DBGIO I/O log wanted? @SC88168 05721000 BZ RTRN No, skip it @SC88168 05722000 L 2,LOGBUF Ptr to buffer @SC87286 05723000 MVI 0(2),C'A' Set label @SC87286 05724000 L 3,FSFSRB 05725000 MVC 2(3,2),0(3) Copy into buffer @SC87286 05726000 LR 9,15 Save data length @SC87286 05727000 WRITF LOGPTR,BSIZE=5 Log it @SC87286 05728000 TM DBGFLG,DBGSV Save log? @SC88168 05729000 BZ SCRIOLZ No, skip it @SC88168 05730000 SAVEF LOGPTR Yes, close it @SC88168 05731000 SCRIOLZ DS 0H @SC88168 05732000 LR 15,9 Return data length @SC87286 05733000 B RTRN Return @SC86299 05734000 * 05735000 SCRWM MVI FSFSFG,X'86' EW, WCC included, Skip Read 05736000 MVI FSFSFG+1,X'A0' No data Compression 05737000 MVC FSFSWL(4),4(1) Get buffer length 05738000 MVC FSFSWB(4),0(1) Get buffer address 05739000 MVI ZLU,9 Specify Unit 9 05740000 MFSET DSKST,FSIO 05741000 MFREQ DSKST Do the I/O 05742000 B RTRN0 05743000 RIOPRP DC A(0,1) @PG90058 05743500 LOCALS , 05744000 SCRNIO EXIT , 05745000 TITLE 'DISKIO Routine - performs disk I/O functions' 05746000 * Function selected on entry by R0: 05747000 * 0=> unnum: R1->FAB. Return R1->buffer,R0=# and remove the sequence 05748000 * number (if any) from the buffer (used for TAKE files) 05749000 * 1=> open (in): R1->pattern FDB, R2->name. Returns R0->FAB, R1->FDB 05750000 * 2=> open (out): (same) 05751000 * 3=> test name: R2->name. Returns R1->FDB if found (else R15=1) 05752000 * 4=> close file: R1->adr(FAB). 05753000 * 5=> set up search: R1->pattern name. 05754000 * 6=> return next file in list: Returns R1->FDB + sets up FILNAM 05755000 * 7=> close search (if any). 05756000 * 8=> test CWD string: R1->string. Returns R15=0 if ok, else =1. 05757000 * 9=> read: R1->FAB. Returns R15=12 if EOF, 0 if ok; R0=# data 05758000 * 10=> write: R1->FAB. Returns R15=13 if disk full, 0 if ok. 05759000 * 11=> test space: R1->pattern FDB (has size in Kbytes), 05760000 * R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok. 05760500 * 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code 05761000 * always returns R15=1 05762000 * 13=> directory info on file: R1->name. Returns R15=0 if ok. 05763000 * 14=> delete file: R1->name. Returns R15=0 if ok. 05764000 * 15=> rename file: R1->name, R2->new name. Returns R15=0 if ok. 05765000 * 16=> copy file: R1->name, R2->new name. Returns R15=0 if ok. 05766000 * 17-> type file: R1-> name. Returns R15=0 if ok. 05767000 * 21=> save file status in directory: R1->FAB. @SC88168 05768000 * 22=> open library (in): R2->DDNAME. Return R15=0 if ok. @SC89073 05768200 * 23=> point for next read, R1->adr(FDB), R2=records to skip. @SC89218 05768300 * Return R15=0 if ok. @SC89218 05768400 DISKIO ENTER 05769000 USING FABD,3 @SC86295 05770000 SR 4,4 Signal no block assigned @SC86295 05771000 STC 0,DSKCOD Save function code (for now) @SC88101 05772000 LR 5,0 @SC89073 05773000 AR 5,5 @SC89073 05773200 LH 5,DSK0(5) Get handler address @SC89073 05773400 B DSK0(5) Do the function @SC89073 05773600 DSK0 DC Y(DSKRED-DSK0,DSKOPNI-DSK0,DSKOPNO-DSK0) 0-2 @SC89073 05773800 DC Y(DSKTEST-DSK0,DSKCLOS-DSK0,DSKNSET-DSK0) 3-5 @SC89073 05774000 DC Y(DSKNXT-DSK0,DSKXSET-DSK0,DSKCWDF-DSK0) 6-8 @SC89073 05774200 DC Y(DSKRED-DSK0,DSKWRT-DSK0,DSKTSP-DSK0) 9-11 @SC89073 05774400 DC Y(DSKXXX-DSK0,DSKDIR-DSK0,DSKDEL-DSK0) 12-14 @SC89073 05774600 DC Y(DSKRNM-DSK0,DSKCPY-DSK0,DSKTYP-DSK0) 15-17 @SC89073 05774800 DC 3Y(DSKER1-DSK0) Spare utilities 18-20 @SC89073 05775000 DC 2Y(DSKER1-DSK0),Y(DSKPNT-DSK0) 21-23 @SC89218 05775200 DC 8Y(DSKER1-DSK0) Spares @SC89073 05775400 * 05776000 * Open for input file whose name is at (R2), FDB at (R1) 05777000 DSKOPNI DS 0H @SC89073 05777500 BAL 9,DSKALC Get FAB @SC86295 05778000 MFSET DSKST,OPEN,R=(OKOLD,RDOK) 05779000 MFREQ DSKST Try to open file 05780000 CLI ZRC,0 Errors ??? 05781000 BNZ DSKER1 Not found @SC86295 05782000 MVC FABRC,ZRC 05783000 BAL 9,DSKCHKNM Check if allowed to do I/O 05784000 B DSKER1 05785000 BAL 14,DSKVALS Go copy info to FDBD 05786000 MVC FABUNIT(1),ZLU Save file unit number 05787000 B RTRN0 @SC86295 05788000 * 05789000 * Open for output file whose name is at (R2), FDB at (R1) 05790000 DSKOPNO DS 0H @SC89073 05791000 BAL 9,DSKALC Get FAB @SC86295 05792000 MVC FABCOMM,=CL8'Open' In case of error @SC88308 05793000 MFSET DSKST,EXTRACT @SC88308 05796000 MFREQ DSKST Get file attributes @SC88308 05797000 CLI ZRC,0 Did it work? @SC88308 05798000 BNE DSKOP2 Not found, just writing new @SC87012 05799000 TM FDBFLGS,APPN+SVATT Should we keep attributes? @SC90033 05799500 BZ *+8 No @SC90033 05800000 BAL 14,DSKVALS Yes, copy old ones to FDB @SC90033 05800500 TM FDBFLGS,APPN Appending? @SC90033 05801000 BO DSKOP2 Yes, keep old file @SC90033 05801500 DSKOP1 DS 0H @SC88308 05802000 MFSET DSKST,OPEN,R=(OKOLD,RDOK) 05803000 MFREQ DSKST 05804000 MVC FABRC(1),ZRC 05805000 CLI ZRC,30 Error deleting file ? 05806000 BE DSKOP2 Yup, ignore it. 05807000 BAL 9,DSKCHKNM Check if allowed to do I/O 05808000 B DSKER1 05809000 MFSET DSKST,CLOSE,R=(DEL) 05810000 MFREQ DSKST Delete the file... 05811000 MVC FABRC(1),ZRC 05812000 DSKOP2 MVC ZINFIN(LZINFDEF),ZINFDEF Get default file attrs 05813000 SR 0,0 05814000 ICM 0,3,FDBLRC Insert logical record length 05815000 STH 0,MFIRSIZ 05816000 CLI FDBRCF,C'V' If not variable, then truncate 05817000 BNE DSKSTLR @SC88120 05818000 CLI TYPFIL,C'B' If variabel BUT binary, truncate 05819000 BE DSKSTLR 05820000 L 0,MAXLRC TEXT file, no limit @SC87012 05821000 DSKSTLR ST 0,FABLRTR Set output buffer limit 05822000 CLI FDBRCF,C'F' Fixed format ? 05823000 BNE *+8 05824000 MVI MFIRFM,X'02' Yup, set to Fixed Compressed 05825000 MFSET DSKST,OPEN,R=(OKOLD,OKNEW,WROK) 05826000 TM FDBFLGS,APPN Append to file ? 05827000 BZ *+8 05828000 OI DSKST+1,X'20' Manually specify APPOK ! 05829000 MFREQ DSKST Do the I/O 05830000 CLI ZRC,0 Any errors ? 05831000 BNZ DSKER1 05832000 MVC FABRC,ZRC Save return code 05833000 MVC ZINFOUT(LZINFDEF),ZINFIN Copy creation file parms 05834000 BAL 14,DSKVALS Copy parms to FDBD 05835000 OI FDBFLGS,FWRITE Write mode file 05836000 MVC FABUNIT(1),ZLU Save the Unit number 05837000 B RTRN0 @SC86295 05838000 * 05839000 * Test for existence of file whose name is at (R2) 05840000 DSKTEST DS 0H @SC89073 05841000 MVC MFNAME(LFID),0(2) Get filename to test 05842000 DSKTST2 LA 3,DSKSTT Get temporary FDB @SC88308 05843000 MFSET DSKST,EXTRACT @SC88308 05844000 MFREQ DSKST Get the file info... 05845000 MVI ZLU,0 Safety check... 05846000 CLI ZRC,0 Any errors ? 05847000 BNZ DSKER1 05848000 BAL 14,DSKVALS Go copy info to FDBD 05849000 B RTRN0 05850000 * 05851000 * Close file whose ticket is at (R1), release block 05852000 DSKCLOS DS 0H @SC89073 05853000 ICM 3,15,0(1) Get FAB ptr, if any @SC86295 05854000 BZ RTRN0 None, ignore @SC86295 05855000 XC 0(4,1),0(1) Yes, now clear ticket @SC86295 05856000 MVC ZLU(1),FABUNIT Copy file Unit number 05857000 LR 6,3 Save the address of the FAB 05858000 MFSET DSKST,CLOSE 05859000 TM FDBFLGS,FWRITE Write mode file ? 05860000 BZ DSKCLS2 05861000 OI DSKST+1,X'10' Yes, add RLSE option ! 05862000 DSKCLS2 MFREQ DSKST Close the file 05863000 LR 1,6 Get FAB address 05864000 LA 0,FABDWDS @SC86295 05865000 DMSFRET DWORDS=(0),LOC=(1) Free up the FAB 05866000 B RTRN0 @SC86295 05867000 * 05867080 * Point past 1st N records of file at (R1) @SC89218 05867160 DSKPNT ICM 3,15,0(1) Get ticket @SC89218 05867240 BZ RTRN1 Not open @SC89218 05867320 LR 3,1 @SC89218 05867400 LTR 2,2 Number of records to skip @SC89218 05867480 BNP RTRN0 Never mind @SC89218 05867560 DSKPNTL READF 0(,3),E=RTRN1 Skip one @SC89218 05867640 BCT 2,DSKPNTL ... until finished @SC89218 05867720 B RTRN0 Return with completion code @SC89218 05867800 * 05868000 * Read from file R1->FAB 05869000 DSKRED DS 0H @SC89073 05870000 DSKRED2 LR 3,1 Point to FAB 05871000 MVC FABCOMM(8),=CL8'Read' I/O Operation 05872000 L 0,FDBBUFF Get buffer address 05873000 ST 0,MFRBUF 05874000 L 0,FDBBSIZ Get I/O Length 05875000 ST 0,MFRLEN 05876000 MVC ZLU(1),FABUNIT Get unit number 05877000 MFSET DSKST,IO,R=(RD) 05878000 MFREQ DSKST Do the I/O 05879000 MVC FABRC(1),ZRC Save the return code 05880000 L 0,MFARSZ Get length read from Save file. 05881000 RETREG 0 Return length as R0 @SC89218 05882000 CLI ZRC,0 Any errors ??? 05884000 BE RTRN0 05885000 LA 15,12 End of file. 05886000 CLI ZRC,1 End of file maybe ??? 05887000 BE RTRN 05888000 B RTRN1 Well, just another error... 05889000 * 05890000 * Write to file R1->FAB 05891000 DSKWRT DS 0H @SC89073 05892000 LR 3,1 Point to FAB 05893000 MVC FABCOMM(8),=CL8'Write' I/O Operation 05894000 L 0,FDBBUFF Get buffer address 05895000 ST 0,MFRBUF 05896000 L 0,FDBBSIZ Get I/O Length 05897000 ST 0,MFRLEN 05898000 MVC ZLU(1),FABUNIT Get unit number 05899000 MFSET DSKST,IO,R=(WR) 05900000 MFREQ DSKST Do the I/O 05901000 MVC FABRC(1),ZRC Save the return code 05902000 CLI ZRC,0 Any errors ??? 05903000 BE RTRN0 05904000 LA 15,13 Disk full error code. 05905000 CLI ZRC,40 Well, is it full ? 05906000 BL RTRN1 05907000 CLI ZRC,42 Three possible return codes 05908000 BH RTRN1 05909000 B RTRN 05910000 * 05911000 * Analyze error: Get error code from FABRC field of FAB ! 05912000 DSKXXX DS 0H @SC89073 05913000 LR 3,1 Get address of FAB 05914000 MVI ERRNUM,ERRDIE Set Kermit DISKIO error code 05915000 L 2,EMSGP Ptr to msg buffer 05916000 MVC 0(8,2),FABCOMM Copy oprn name 05917000 MVC ZRC(1),FABRC Get the error code 05918000 LA 0,8(2) Get address of where to pad 05919000 ST 0,MFRBUF message 05920000 LA 0,70 Maximum length of message 05921000 ST 0,MFRLEN 05922000 MFSET DSKST,MSG Convert RC to real message 05923000 MFREQ DSKST 05924000 LA 0,79 Return maximum length of msg. 05925000 ST 0,EMSGL 05926000 B RTRN1 @SC87338 05927000 * 05928000 * Delete file R1->name, Return R15=0 if ok 05929000 DSKDEL DS 0H @SC89073 05930000 LA 3,DSKSTT Temporary FAB needed 05931000 MVC MFNAME(LFID),0(1) Copy file name to delete 05932000 MFSET DSKST,OPEN,R=(OKOLD,RDOK) 05933000 MFREQ DSKST Try to open the file 05934000 CLI ZRC,0 Error ? 05935000 BNE DSKER2 05936000 BAL 9,DSKCHKNM Check if allowed to do I/O 05937000 B DSKER2 05938000 MFSET DSKST,CLOSE,R=(DEL) 05939000 MFREQ DSKST Delete the file 05940000 CLI ZRC,0 Error ? 05941000 BNE DSKER2 05942000 LA 2,0 File deleted message 05943000 * 05944000 DSKMSG SLL 2,4 Get the address of the message 05945000 LA 1,DSKMTAB(2) @SC88308 05946000 LA 0,16 Length of msg @SC88308 05947000 WTEXT (1),(0) @SC88308 05948000 MVI ERRNUM,ERRNOE No Errors 05949000 B RTRN0 05950000 * 05951000 * Rename file R1->name, R2->newname, Return R15=0 if ok 05952000 DSKRNM DS 0H @SC89073 05953000 LA 3,DSKSTT Temporary FAB needed 05954000 MVC MFNAME(LFID),0(1) Copy file name to delete 05955000 MFSET DSKST,OPEN,R=(OKOLD,RDOK) 05956000 MFREQ DSKST Try to open the file 05957000 CLI ZRC,0 Error ? 05958000 BNE DSKER2 05959000 BAL 9,DSKCHKNM Check if allowed to do I/O 05960000 B DSKER2 05961000 MVC ZINFIN(LZINFDEF),ZINFDEF Get default file attrs 05962000 MVC MFNAME(LFID),0(2) Get new name 05963000 MFSET DSKST,CLOSE,R=(RENAME) 05964000 MFREQ DSKST Rename it ! 05965000 LA 2,1 File renamed message 05966000 CLI ZRC,0 Error on rename ? 05967000 BE DSKMSG 05968000 CLI ZLU,0 Is an additional close required ? 05969000 BE DSKER2 05970000 MFSET DSKST,CLOSE Yes, close the file normally. 05971000 MFREQ DSKST Rename failed. 05972000 B DSKER2 05973000 * 05974000 * Copy file. R1->name, R2->newname. Return R15=0 if ok 05975000 DSKCPY DS 0H @SC89073 05976000 LA 3,DSKSTT Temporary FAB needed 05977000 LA 7,1 Error by default !!! 05978000 MVC MFNAME(LFID),0(1) Get file name to copy 05979000 MFSET DSKST,OPEN,R=(OKOLD,RDOK) 05980000 MFREQ DSKST Try to open the file 05981000 CLI ZRC,0 Error ? 05982000 BNE DSKER2 05983000 BAL 9,DSKCHKNM Check if allowed to do I/O 05984000 B DSKER2 05985000 SLR 8,8 05986000 ICM 8,1,ZLU Save Read Unit Number 05987000 L 9,MFEOFB Get number of blks to copy 05988000 MVC PARMAREA(2),MFORSIZ Save record size 05989000 MVC PARMAREA+2(4),MFNLRC Save Line count 05990000 MVC PARMAREA+6(4),MFEOFB Save last blk written 05991000 MVC PARMAREA+10(4),MFEOFD Save displacement 05992000 MVC CMD(64),MFTAG Save tag @SC88308 05993000 * 05994000 MVC MFNAME(LFID),0(2) Get destination 05995000 MVC ZINFIN(LZINFDEF),ZINFOUT 05996000 NI MFIGCTL,X'7F' Turn off common bit !!! 05997000 MFSET DSKST,OPEN,R=(OKNEW,WROK) 05998000 MFREQ DSKST Try to open the file 05999000 CLI ZRC,0 06000000 BNE DSKCP55 Error. New file open failed ! 06001000 ICM 8,2,ZLU Save Write Unit Number 06002000 * 06003000 LA 4,1 Starting blk number 06004000 LA 5,512 Number of blks to copy 06005000 LA 6,2048 Address of buffer 06006000 A 6,WBUF 06007000 LTR 9,9 Anything left to do ??? 06008000 BZ DSKCP50 06009000 DSKCP20 STCM 8,1,ZLU Set Unit number 06010000 STM 4,6,MFSBNU Set read args 06011000 MFSET DSKST,UIO,R=(RD) 06012000 MFREQ DSKST Read a block 06013000 CLI ZRC,0 Error reading ? 06014000 BNE DSKCP55 06015000 STCM 8,2,ZLU Set unit number 06016000 STM 4,6,MFSBNU Set read args 06017000 MFSET DSKST,UIO,R=(WR) 06018000 MFREQ DSKST Write the block back 06019000 CLI ZRC,0 Error writing? @SC88308 06020000 BNE DSKCP55 06021000 LA 4,1(4) Next block 06022000 BCT 9,DSKCP20 until all done 06023000 * 06024000 DSKCP50 SLR 7,7 Clear return code ! 06025000 DSKCP55 STCM 8,1,ZLU 06026000 CLI ZLU,0 Is the input file open ??? 06027000 BE DSKCP60 06028000 MFSET DSKST,CLOSE Yes, close the input file. 06029000 MFREQ DSKST 06030000 ICM 7,2,ZRC Save the return code 06031000 DSKCP60 STCM 8,2,ZLU 06032000 CLI ZLU,0 Is the output file open ? 06033000 BE DSKCP80 06034000 LTR 7,7 Any errors so far ? 06035000 BNZ DSKCP65 06036000 MFSET DSKST,CLOSE,R=(SETEFP) No, close and save file 06037000 MVC MFORSIZ(2),PARMAREA Set record size 06038000 MVC MFNLRC(4),PARMAREA+2 Set Line count 06039000 MVC MFEOFB(4),PARMAREA+6 Set last blk written 06040000 MVC MFEOFD(4),PARMAREA+10 Set displacement 06041000 MVC MFTAG(64),CMD Restore tag @SC88308 06042000 B DSKCP70 06043000 DSKCP65 MFSET DSKST,CLOSE,R=(DEL) Errors, delete file ! 06044000 DSKCP70 MFREQ DSKST 06045000 ICM 7,4,ZRC Get return code on Close 06046000 DSKCP80 LR 15,7 Return it to Kermit ! 06047000 B RTRN 06048000 * 06049000 * Type file. R1-> name. Returns R15=0 if ok. 06050000 DSKTYP DS 0H @SC89073 06051000 LR 4,1 Point to file name @PG88335 06052000 OPENF I,(4),FILFDB,FILPTR,E=RTRN1 @PG88335 06053000 LR 3,0 Point to FAB @PG88335 06054000 LH 1,FDBLRC @PG88335 06055000 CH 1,=H'130' Check record length !!! @PG88335 06056000 BL DSKTYP20 @PG88335 06057000 WTEXT 'Only first 130 characters displayed!' @PG88335 06058000 DSKTYP20 L 3,RBUF Point to data buffer @PG88335 06059000 READF FILPTR,BUFFER=(3),E=DSKTYP50 @PG88335 06060000 CH 0,=H'130' Record too long ? @PG88335 06061000 BL DSKTYP30 @PG88335 06062000 LA 0,129 Yes, truncate... @PG88335 06063000 DSKTYP30 LTR 0,0 Is it null ? @PG88335 06064000 BNZ DSKTYP35 @PG88335 06065000 MVI 0(3),X'40' Then we must have at least @PG88335 06066000 LA 0,1 one character to output @PG88335 06067000 DSKTYP35 WTEXT (3) @PG88335 06068000 B DSKTYP20 @PG88335 06069000 DSKTYP50 C 15,F12 EOF code ? @PG88335 06070000 BE DSKTYP70 @PG88335 06071000 ERRF , Analyze error code @PG88335 06072000 CLOSF FILPTR @PG88335 06073000 B RTRN1 @PG88335 06074000 DSKTYP70 CLOSF FILPTR @PG88335 06075000 B RTRN0 @PG88335 06076000 * 06077000 * Return on error, release useless block, if any 06078000 DSKER1 LTR 1,4 Any block assigned? @SC86295 06079000 BZ RTRN1 No @SC86295 06080000 LA 0,FABDWDS Yes, release it @SC86295 06081000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 06082000 B RTRN1 Flag error @SC86295 06083000 * Error return from disk utilities. Set ERRNUM properly. 06084000 DSKER2 CLI ZRC,12 06085000 BNE DSKER3 06086000 MVI ERRNUM,ERRFNE Invalid filename 06087000 B RTRN1 06088000 DSKER3 CLI ZRC,30 06089000 BNE DSKER4 06090000 MVI ERRNUM,ERRFNF File not found 06091000 B RTRN1 06092000 DSKER4 MVI ERRNUM,ERRDIE Disk I/O Error 06093000 B RTRN1 06094000 * Allocate FAB and copy default FDB 06095000 DSKALC LR 5,1 Save FDB ptr @SC86295 06096000 MVC MFNAME,0(2) 06097000 LA 0,FABDWDS @SC86295 06098000 DMSFREE DWORDS=(0),ERR=DSKER1 @SC86295 06099000 LR 3,1 New block ptr @SC86295 06100000 LA 4,FDBD FDB pointer @SC88120 06101000 RETREG (0,3),(1,4) Return FAB ptr in R0, FDB in R1 @SC89218 06102000 LR 4,3 Indicate we have it @SC88120 06104000 XC 0(8*FABDWDS,3),0(3) @SC86295 06105000 MVC FDBD(FDBCOP),0(5) Copy user's FDB @SC86295 06106000 MVC FABFN(LFID),0(2) Copy filename to FAB 06107000 BR 9 @SC86295 06108000 * 06109000 * Set up search through list of files, pattern at (R1) 06110000 DSKNSET DS 0H @SC89073 06111000 MVC SCODE,UCODE Get default user code 06112000 MVC NXFN(LFID),0(1) Save pattern name 06113000 CLI 4(1),C':' Code specified in filename ? 06114000 BNE DSKNS4 Nope. 06115000 MVC SCODE(4),0(1) Get the new code for search 06116000 MVC NXFN(LFID),BLNAME Clear the filename pattern 06117000 MVC NXFN(17),5(1) Copy filename part only 06118000 DSKNS4 CLC SCODE(4),=CL4'*USR' Do we really want the user's code ? 06119000 BNE DSKNS6 06120000 MVC SCODE(4),$USRCDE Yes, then put in the real thing 06121000 DSKNS6 MVI NXFLG,NFSOK Clear flag byte 06122000 LA 2,LFID Max length of filename 06123000 LA 3,NXFN+LFID 06124000 DSKNS8 BCTR 3,0 06125000 CLI 0(3),C'?' Is it a wildcard ? 06126000 BE DSKNS10 06127000 CLI 0(3),C'*' Is it a wildcard ? 06128000 BE DSKNS10 06129000 BCT 2,DSKNS8 06130000 B RTRN0 No wildcards, Grreat !!! 06131000 * 06132000 DSKNS10 CLC SCODE(4),$USRCDE Are we searching our library ? 06133000 BE DSKNS12 06134000 TM UPRIVS,FILES+LSCAN No, then we need some privs !!! 06135000 BZ DSKNS15 06136000 DSKNS12 LA 1,NXFN+LFID End of token if no blanks 06137000 TRT NXFN(LFID),TRTBL Find 1st blank 06138000 LA 2,NXFN 06139000 SR 1,2 Calc length of string 06140000 ST 1,NXFNL Save it... 06141000 OI NXFLG,NFWLD Wildcard search necessary ! 06142000 L 2,MFINDBUF 06143000 CALL MFIND1,((2),F10,SCODE,F0,ZRC),VL,MF=(E,PARMAREA) 06144000 LTR 15,15 Any errors ??? 06145000 BZ RTRN0 06146000 DSKNS15 OI NXFLG,NFERR Error on MFIND1 call 06147000 B RTRN1 06148000 * 06149000 * Flush previous file pattern 06150000 DSKXSET DS 0H @SC89073 06151000 MVI NXFLG,0 Clear flag byte 06152000 B RTRN0 06153000 * 06154000 * Check CWD string, return code in R15 06155000 DSKCWDF DS 0H @SC89073 06156000 B RTRN0 06157000 * 06158000 * Check disk space for proposed file: FDB at (R1), FAB ptr at (R6) 06159000 DSKTSP L 5,FDBSIZE-FDBD(,1) Get actual size @SC90037 06159200 ICM 3,15,0(6) Get FAB ptr @SC90037 06159400 BNZ DSKTSP0 Not open yet @SC90037 06159600 MVC MFNAME(LFID),0(2) Get filename @SC90037 06159800 LA 3,DSKSTT Get temporary FDB @SC90037 06160000 MFSET DSKST,EXTRACT @SC90037 06160200 MFREQ DSKST Get the file info @SC90037 06160400 MVI ZLU,0 For safety @SC90037 06160600 CLI ZRC,0 Found it? @SC90037 06160800 BNE DSKTSP0 Not found, nothing to erase @SC90037 06161000 L 1,MFOPRM Old file size in KBytes @SC90037 06161200 SR 5,1 Assume old file will be erased @SC90037 06161400 BNP RTRN0 Will release enough for new file @SC90037 06161600 DSKTSP0 DS 0H Check free space @SC90037 06161800 MFSET DSKST,USERCTL Get User Control Record to 06163000 MFREQ DSKST determine how much space the 06164000 MVC FABRC(1),ZRC user has left. Save return code ! 06165000 L 1,MFMAXS Get max allocation space 06166000 S 1,MFACUR Subtract amt allocated 06167000 CLR 1,5 @SC90037 06168000 BL RTRN1 No room @SC86316 06169000 B RTRN0 Ok @SC86316 06170000 * 06171000 DSKVALS LA 0,FDBD Ptr to FDB @SC86295 06172000 RETREG (1,0) Return FDB ptr as R1 @SC89218 06173000 *** GET FILE'S DATE... 06175000 SR 7,7 @SC87296 06176000 IC 7,DS1CRDT Get year in binary @SC87296 06177000 CVD 7,TMPDW @SC87296 06178000 MVO FDBDATE+1(2),TMPDW Copy year @SC87296 06179000 ICM 7,3,DS1CRDT+1 Get day-of-year in binary @SC87296 06180000 MVC DSKMNTH,=AL1(30,31,30,31,31,30,31,30,31,28,31) @SC86299 06181000 TM DS1CRDT,3 @SC87296 06182000 BNZ *+8 @SC87296 06183000 MVI DSKMNTH+9,29 Leap year, change Feb. @SC86299 06184000 LA 6,11 @SC86299 06185000 SR 0,0 @SC86299 06186000 DSKVMDL IC 0,DSKMNTH-1(6) @SC86299 06187000 SR 7,0 Test if passed the right month @SC86299 06188000 BNP DSKVMDM Got it @SC86299 06189000 BCT 6,DSKVMDL @SC86299 06190000 SR 0,0 Hit December @SC86299 06191000 DSKVMDM AR 7,0 Get day of month @SC86299 06192000 LCR 6,6 @SC86299 06193000 LA 6,12(6) Get month @SC86299 06194000 MH 6,=H'100' @SC86299 06195000 AR 6,7 Combine MMDD @SC86299 06196000 MH 6,=H'10' @SC86299 06197000 CVD 6,TMPDW @SC86299 06198000 MVC FDBDATE+2(2),TMPDW+5 @SC86299 06199000 MVI FDBDATE,X'19' Assume 20th Cent @SC86295 06200000 CLI FDBDATE+1,X'50' @SC86295 06201000 BH *+8 Ok @SC86295 06202000 MVI FDBDATE,X'20' Must be 21st @SC86295 06203000 L 1,MFOPRM Set file size in KBytes 06204000 ST 1,FDBSIZE 06205000 SLR 1,1 Set record format character 06206000 IC 1,MFORFM Ignore 'Compressed' modes. 06207000 SLL 1,1 06208000 LA 0,RFMTAB 06209000 AR 1,0 06210000 MVC FDBRCF,0(1) 06211000 MVC FDBLRC(2),MFORSIZ Get logical record length 06212000 NI FDBFLGS,255-FWRITE Clear the write mode flag 06213000 BR 14 06214000 * 06215000 * NXTFST Routine - searches through Save Library Index 06216000 * 06217000 DSKNXT DS 0H @SC89073 06218000 TM NXFLG,NFSOK Was a search set up ??? 06219000 BZ RTRN1 06220000 TM NXFLG,NFERR+NFEND Error or End of search ??? 06221000 BNZ RTRN1 06222000 * 06223000 TM NXFLG,NFWLD Do we need to call MFINDX ? 06224000 BO DSKSRCH 06225000 OI NXFLG,NFEND End of search... 06226000 LA 1,NXFN Source name was good. Use it! 06227000 DSKFND MVC MFNAME(5),SCODE Rebuild the complete filename @SC88308 06228000 MVC MFNAME+5(17),0(1) info on the file. 06229000 MVC FILNAM(LFID),MFNAME Setup FILNAM !!! 06230000 B DSKTST2 06231000 * 06232000 DSKSRCH CALL MFINDX,(FCODE,LCFN,NXFLTYP,NXSVFLG,NXBKNUM,NXDIRLOC),VL,+06233000 MF=(E,PARMAREA) 06234000 C 15,F4 End of library search ? 06235000 BNE NXT20 06236000 OI NXFLG,NFEND Yes, end of search 06237000 B RTRN1 06238000 NXT20 LTR 15,15 Error in search ? 06239000 BZ NXT30 06240000 OI NXFLG,NFSERRS+NFERR Yes, error in search @SC88308 06241000 B RTRN1 06242000 NXT30 CLC NXFLTYP,F0 Skip over common entries 06243000 BNE DSKSRCH 06244000 CLI LCFN,C'.' Skip over temporary files 06245000 BE DSKSRCH 06246000 CLC FCODE(4),SCODE Is this the right code ??? 06247000 BNE DSKSRCH 06248000 CALL MATCH,(LCFN,FM17,NXFN,NXFNL,ASTER,QUEST),VL, +06249000 MF=(E,PARMAREA) 06250000 LTR 0,0 Well, did they match ??? 06251000 BZ DSKSRCH 06252000 LA 1,LCFN Point to name found and go 06253000 B DSKFND copy it and set FDB 06254000 * 06255000 * Directory Info on file R1->name, return R15=0 if OK 06256000 DSKDIR DS 0H @SC89073 06257000 NXTFSET E=DSKDRERR Set up search (name at R1) @SC88308 06258000 DSKDRLP NXTF E=DSKDRZ Find next entry @SC88308 06259000 OI NXFLG,NFFND Found something, at least one @SC88308 06260000 LA 1,CMD Yes, build the filename with @SC88308 06261000 LR 2,1 the attributes we want in a 06262000 LA 3,LFID Length of name buffer @SC88308 06263000 LA 4,MFNAME @SC88308 06264000 LR 5,3 @SC88308 06265000 CLC 0(4,4),$USRCDE User's code? @SC88308 06266000 BNE *+12 No @SC88308 06267000 A 4,F5 Yes, skip over it for output @SC88308 06268000 S 3,F5 @SC88308 06269000 MVCL 2,4 @SC88308 06270000 ICM 0,3,MFORSIZ 06271000 BAL 9,DSKNUM Add the logical record length 06272000 MVC 0(2,2),BLNAME Leave some blanks @SC88308 06273000 SLR 3,3 06274000 IC 3,MFORFM Get record format 06275000 SLL 3,1 06276000 LA 3,RFMTAB(3) Get address of printable value 06277000 MVC 2(2,2),0(3) Add to line @SC88308 06278000 LA 2,4(2) Bump the length @SC88308 06279000 ICM 0,15,MFOPRM 06280000 BAL 9,DSKNUM Add the file size in Kbytes 06281000 MVI 0(2),C'K' 06282000 LA 2,1(2) 06283000 ICM 0,15,MFNLRC Add the number of lines 06284000 BAL 9,DSKNUM 06285000 MVC 0(6,2),=C' lines' 06286000 LA 2,6(2) 06287000 * 06288000 SR 2,1 Get the output length 06289000 WTEXT (1),(2) 06290000 B DSKDRLP @SC88308 06291000 * @SC88308 06292000 DSKDRZ TM NXFLG,NFSERRS+NFERR @SC88308 06293000 BNZ DSKDRERR Report error @SC88308 06294000 TM NXFLG,NFFND Any files found? @SC88308 06295000 BO RTRN0 Yes, return gracefully @SC88308 06296000 DSKDRERR PTEXT 'Not found' @SC88308 06297000 B SUBERR @SC88308 06298000 * 06299000 DSKNUM CVD 0,TMPDW Pack the binary value 06300000 OI TMPDW+7,15 Set zone 06301000 UNPK 0(8,2),TMPDW Convert to printable 06302000 LA 5,7(2) Point to end of string 06303000 DSKNUM2 CLI 0(2),C'0' Remove leading zeros 06304000 BNE DSKNUM3 except for the first one. 06305000 MVI 0(2),C' ' 06306000 LA 2,1(2) 06307000 CR 2,5 06308000 BL DSKNUM2 06309000 DSKNUM3 LA 2,1(5) Get the new ending address 06310000 BR 9 06311000 * 06312000 * Check for privs to open filename 06313000 * R3->FAB, R9->returns @SC88308 06314000 DSKCHKNM TM UPRIVS,FILES+LSCAN If FILES, never any problems 06315000 BNZ 4(9) 06316000 CLC MFUIFC(4),$USRCDE If our own code, then no problem 06317000 BE 4(9) 06318000 TM MFOACNB,X'A0' Allowed to read file ??? 06319000 BZ 4(9) 06320000 MVI FABRC,21 Not your library error. 06321000 CLI ZLU,0 Is the file still open ? 06322000 BER 9 06323000 MFSET DSKST,CLOSE Yes, close it normally... 06324000 MFREQ DSKST 06325000 BR 9 Error return 06326000 * 06327000 RFMTAB DC C'U F FCV VC' Record Format Table 06328000 DSKMTAB DC CL16'File deleted' 06329000 DC CL16'File renamed' 06330000 DC CL16'File copied' 06331000 LOCALS , 06332000 DS1CRDT DS XL1,XL2 Creation date AL1(yr),AL2(day) @SC86299 06333000 DSKMNTH DS XL11 Month length table @SC86299 06334000 DSKCOD DS X Saved DISKIO code @SC88308 06335000 DROP R3 06336000 EXIT 06337000 EJECT 06338000